home *** CD-ROM | disk | FTP | other *** search
/ Night Owl 9 / Night Owl CD-ROM (NOPV9) (Night Owl Publisher) (1993).ISO / 012a / lib194.zip / STRINGS.PRG < prev    next >
Text File  |  1993-01-19  |  47KB  |  1,296 lines
  1. *-------------------------------------------------------------------------------
  2. *-- Program...: STRINGS.PRG
  3. *-- Programmer: Ken Mayer (CIS: 71333,1030)
  4. *-- Date......: 08/31/1992
  5. *-- Notes.....: String manipulation routines -- These routines are all designed
  6. *--             to handle the processing of "Strings" (Character Strings).
  7. *--             They range from simple checking of the location of a string 
  8. *--             inside another, to reversing the contents of a string ... 
  9. *--             and lots more. See the file: README.TXT for details on use
  10. *--             of this (and the other) library file(s).
  11. *-------------------------------------------------------------------------------
  12.  
  13. FUNCTION Proper
  14. *-------------------------------------------------------------------------------
  15. *-- Programmer..: Clinton L. Warren (VBCES)
  16. *-- Date........: 07/10/1991
  17. *-- Notes.......: Returns cBaseStr converted to proper case.  Converts
  18. *--               "Mc", "Mac", and "'s" as special cases.  Inspired by
  19. *--               A-T's CCB Proper function.  cBaseStr isn't modified.
  20. *-- Written for.: dBASE IV, 1.1
  21. *-- Rev. History: 07/10/1991 1.0 - Original version (VBCES/CLW)
  22. *-- Calls.......: None
  23. *-- Called by...: Any
  24. *-- Usage.......: Proper(<cBaseStr>)
  25. *-- Example.....: Proper("mcdonald's") returns "McDonald's"
  26. *-- Returns.....: Propertized string (e.g. "Test String")
  27. *-- Parameters..: cBaseStr = String to be propertized
  28. *-------------------------------------------------------------------------------
  29.  
  30.     PARAMETERS cBaseStr
  31.     private nPos, cDeli, cWrkStr
  32.  
  33.     cWrkStr = lower(cBaseStr) + ' '             && space necessary for 's process
  34.  
  35.     nPos = at('mc', cWrkStr)                    && "Mc" handling
  36.     do while nPos # 0
  37.        cWrkStr = stuff(cWrkStr, nPos, 3, upper(substr(cWrkStr, nPos, 1)) ;
  38.                 + lower(substr(cWrkStr, nPos + 1, 1)) ;
  39.                 + upper(substr(cWrkStr, nPos + 2, 1)))
  40.         nPos = at('mc', cWrkStr)
  41.       enddo
  42.  
  43.     nPos = at('mac', cWrkStr)                    && "Mac" handling
  44.     do while nPos # 0
  45.        cWrkStr = stuff(cWrkStr, nPos, 4, upper(substr(cWrkStr, nPos, 1)) ;
  46.                                 + lower(substr(cWrkStr, nPos + 1, 2)) ;
  47.                                 + upper(substr(cWrkStr, nPos + 3, 1)))
  48.         nPos = at('mac', cWrkStr)
  49.     enddo
  50.  
  51.     cWrkStr = stuff(cWrkStr, 1, 1, upper(substr(cWrkStr, 1, 1)))
  52.     nPos = 2
  53.     cDeli = [ -.'"\/`]                           && standard delimiters
  54.  
  55.     do while nPos <= len(cWrkStr)                && 'routine' processing
  56.         if substr(cWrkStr,nPos-1,1) $ cDeli
  57.           cWrkStr = stuff(cWrkStr, nPos, 1, upper(substr(cWrkStr,nPos,1)))
  58.         endif
  59.         nPos = nPos + 1
  60.     enddo
  61.  
  62.     nPos = at("'S ", cWrkStr)                    && 's processing
  63.     do while nPos # 0
  64.         cWrkStr = stuff(cWrkStr, nPos, 2, lower(substr(cWrkStr, nPos, 2)))
  65.         nPos = at('mac', cWrkStr)
  66.     enddo
  67.  
  68. RETURN (cWrkStr)
  69. *-- EoF: Proper()
  70.  
  71. FUNCTION Dots
  72. *-------------------------------------------------------------------------------
  73. *-- Programmer..: Ken Mayer (CIS: 71333,1030)
  74. *-- Date........: 12/17/1991
  75. *-- Notes.......: Based on ideas from Technotes, June, 1990 (see JUSTIFY() ),
  76. *--               this function should pad a field or memvar with dots to the
  77. *--               left, right or both sides. Note that if the field is too
  78. *--               large for the length passed (nLength) it will be truncated.
  79. *-- Written for.: dBASE IV, 1.1
  80. *-- Rev. History: None
  81. *-- Calls.......: ALLTRIM()            Function in PROC.PRG
  82. *-- Called by...: Any
  83. *-- Usage.......: Dots(<cFld>,<nLength>,"<cType>")
  84. *-- Example.....: ?? Dots(Address,25,"R")
  85. *-- Returns.....: Field/memvar with dot leader/trailer ...
  86. *-- Parameters..: cFld    =  Field/Memvar/Character String to justify
  87. *--               nLength =  Width to justify within
  88. *--               cType   =  Type of justification: L=Left, C=Center,R=Right
  89. *-------------------------------------------------------------------------------
  90.     
  91.     parameters cFld,nLength,cType
  92.     private cReturn, nVal, nMore
  93.     
  94.     if type("cFld")+type("nLength")+type("cType") $ "CNC,CFC"
  95.     
  96.         cType   = upper(cType)      && just to make sure ...
  97.         cReturn = AllTrim(cFld)     && trim this puppy on all sides
  98.         if len(cReturn) => nLength  && check length against parameter
  99.                                     && truncate if necessary
  100.             cReturn = substr(cReturn,1,nLength)
  101.         endif
  102.         
  103.         do case
  104.             case cType = "L"  && Left -- add trailing dots to field
  105.                 cReturn = cReturn + replicate(".",nLength-len(cReturn))
  106.             case cType = "R"  && Right -- add leading dots to field
  107.                 cReturn = replicate(".",nLength-len(cReturn))+cReturn
  108.             case cType = "C"  && Center -- add 'em to both sides ...
  109.                 nVal = int( (nLength - len(cReturn)) / 2)
  110.                 *-- here, we have to deal with fractions ...
  111.                 nMore = mod(nlength - len(cReturn), 2)
  112.                 *-- add dots on left, field, dots on right (add one if a fraction)
  113.                 cReturn = replicate(".",nVal)+cReturn+;
  114.                           replicate(".",nVal+iif(nMore>0,1,0))
  115.             otherwise         && invalid parameter ... return nothing
  116.                 cReturn = ""
  117.         endcase
  118.     else
  119.         cReturn = ""
  120.     endif
  121.  
  122. RETURN cReturn
  123. *-- EoF: Dots()
  124.  
  125. FUNCTION CutPaste
  126. *-------------------------------------------------------------------------------
  127. *-- Programmer..: Martin Leon (HMAN)
  128. *-- Date........: 03/05/1992
  129. *-- Notes.......: Used to do a cut and paste within a field/character string.
  130. *--               (Taken from an issue of Technotes, can't remember which)
  131. *--               This function will not allow you to overflow the field/char
  132. *--               string -- i.e., if the Paste part of the function would cause
  133. *--               the returned field to be longer than it started out, it will
  134. *--               not perform the cut/paste (STUFF()). For example, if your 
  135. *--               field were 15 characters, and you wanted to replace 5 of them
  136. *--               with a 10 character string:
  137. *--                      (CutPaste(field,"12345","1234567890"))
  138. *--               If this would cause the field returned to be longer than 15,
  139. *--               the function will return the original field.
  140. *-- Written for.: dBASE IV, 1.1
  141. *-- Rev. History: Original function 12/17/1991
  142. *--               03/05/1992 -- minor change to TRIM(cFLD) in the early
  143. *--               bits, solving a minor problem with phone numbers that
  144. *--               Dave Creek (DCREEK) discovered.
  145. *-- Calls.......: None
  146. *-- Called by...: Any
  147. *-- Usage.......: CutPaste(<cFld>,"<cLookFor>","<cRepWith>")
  148. *-- Example.....: Replace all city with CutPaste(City,"L.A.","Los Angeles")
  149. *-- Returns.....: The field with text replaced (or not, if no match is found)
  150. *-- Parameters..: cFld     = Field/Memvar/Expression to replace in 
  151. *--               cLookFor = Item to look for (Cut)
  152. *--               cRepWith = What to replace it with (Paste)
  153. *-------------------------------------------------------------------------------
  154.  
  155.     parameters cFld,cLookFor,cRepWith
  156.     private lMatched,nLookLen,nLen,nRepLen,cRetFld,nTrimLen,nCutAt
  157.     
  158.     *-- Make sure they're all character fields/strings
  159.     if type("cFld")+type("cLookFor")+type("cRepWith") # "CCC"
  160.         RETURN cFld
  161.     endif
  162.     
  163.     lMatched = .f.
  164.     nLookLen = len(cLookFor)  && length of field to look for
  165.     nLen     = len(cFld)      && length of original field
  166.     nRepLen  = len(cRepWith)  && length of field to replace with
  167.     cRetFld  = trim(cFld)     && trim it ... (DCREEK's suggestion)
  168.     
  169.     *-- the loop will allow a cut/paste to occur more than once in the field
  170.     do while at(cLookFor,cRetFld) > 0
  171.         lMatched = .t.
  172.         cRetFld  = trim(cRetFld)
  173.         nTrimLen = len(cRetFld)
  174.         
  175.         *-- the following IF statement prevents the replacement text
  176.         *-- from overflowing the length of the original string ...
  177.         if(nTrimLen - nLookLen) + nRepLen > nLen
  178.             RETURN cRetFld
  179.         endif
  180.         
  181.         *-- here we figure where to "cut" at
  182.         nCutAt = at(cLookFor,cRetFld)
  183.         *-- let's do the paste ... (using dBASE STUFF() function)
  184.         cRetFld = stuff(cRetFld,nCutAt,nLookLen,cRepWith)
  185.     enddo
  186.     
  187.     if .not. lMatched  && no match with cLookFor, return original field
  188.         RETURN cFld
  189.     endif
  190.     
  191. RETURN cRetFld
  192. *-- EoF: CutPaste
  193.  
  194. FUNCTION LastWord
  195. *-------------------------------------------------------------------------------
  196. *-- Programmer..: Martin Leon (HMAN)
  197. *-- Date........: 12/19/1991
  198. *-- Notes.......: Returns the last word in a character string.
  199. *-- Written for.: dBASE IV, 1.1
  200. *-- Rev. History: None
  201. *-- Calls.......: None
  202. *-- Called by...: Any
  203. *-- Usage.......: LastWord("<cString>")
  204. *-- Example.....: ? LastWord("This is a test string") 
  205. *-- Returns.....: The Last word (bracketed with spaces), i.e.:"string"
  206. *-- Parameters..: cString = string to be searched 
  207. *-------------------------------------------------------------------------------
  208.     
  209.     parameters cString
  210.     private cReturn
  211.     
  212.     cReturn = trim(cString)
  213.     do while at(" ",cReturn) # 0
  214.         cReturn = substr(cReturn,at(" ",cReturn)+1)
  215.     enddo
  216.     
  217. RETURN cReturn
  218. *-- EoF: LastWord()
  219.  
  220. FUNCTION VStretch
  221. *-------------------------------------------------------------------------------
  222. *-- Programmer...: Martin Leon (HMAN -- Ashton Tate/Borland BBS)
  223. *-- Date.........: 10/30/91
  224. *-- Notes........: Used to display a long character field, with proper word wrap
  225. *-- Written for..: dBASE IV, 1.1
  226. *-- Rev. History.: Once upon a time, Martin helped me write a more complicated
  227. *--                routine for use in a browse table. He came up with this
  228. *--                much less complex version recently and sent to me via EMail.
  229. *-- Calls........: None
  230. *-- Called by....: Any
  231. *-- Usage........: ?VStretch(<cLFld>,<nULRow>,<nULCol>,<nBRRow>,<nBRCol>)
  232. *-- Example......: ?VStretch(Notes,20,10,24,60,"rg+/gb")
  233. *-- Returns......: ""  (Nul)
  234. *-- Parameters...: cLFld  = Long Field to be wrapped on screen
  235. *--                nULRow = Upper Left Row of window
  236. *--                nULCol = Upper Left Column
  237. *--                nBRRow = Bottom Right Row of window
  238. *--                nBRCol = Bottom Right Column
  239. *-------------------------------------------------------------------------------
  240.  
  241.     parameter cLFld,nULRow,nULCol,nBRRow,nBRCol
  242.     private nWinWidth
  243.     
  244.     nWinWidth = ltrim(str((nBRCol - nULCol)-1,2))
  245.     *-- define window without any border ...
  246.     define window wStretch from nULRow,nULCol to nBRRow,nBRCol none
  247.     activate window wStretch
  248.     *-- make sure window is empty ...
  249.     clear
  250.     *-- display field
  251.     ?? cLFld picture "@V"+nWinWidth at 0  && the @V function causes word wrap
  252.     save screen to sTemp
  253.     activate screen
  254.     release window wStretch
  255.     restore screen from sTemp
  256.     release screen sTemp
  257.  
  258. RETURN ""
  259. *-- EoF: VStretch()
  260.  
  261. FUNCTION AtCount
  262. *-------------------------------------------------------------------------------
  263. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  264. *-- Date........: 03/01/92
  265. *-- Notes.......: returns the number of times FindString is found in Bigstring
  266. *-- Written for.: dBASE IV
  267. *-- Rev. History: None
  268. *-- Calls.......: None
  269. *-- Called by...: Any
  270. *-- Usage.......: AtCount("<cFindStr>","<cBigStr>")
  271. *-- Example.....: ? AtCount("Test","This is a Test string, with Test data")
  272. *-- Returns.....: Numeric value
  273. *-- Parameters..: cFindStr = string to find in cBigStr
  274. *--               cBigStr  = string to look in
  275. *-------------------------------------------------------------------------------
  276.  
  277.     parameters cFindstr, cBigstr
  278.     private cTarget, nCount
  279.     
  280.     cTarget = cBigstr
  281.     nCount = 0
  282.     
  283.     do while .t.
  284.         if at( cFindStr,cTarget ) > 0
  285.             nCount = nCount + 1
  286.             cTarget = substr( cTarget, at( cFindstr, cTarget ) + 1 )
  287.         else
  288.          exit
  289.         endif
  290.     enddo
  291.     
  292. RETURN nCount
  293. *-- EoF: AtCount()
  294.         
  295. FUNCTION IsAlNum
  296. *-------------------------------------------------------------------------------
  297. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  298. *-- Date........: 03/01/92
  299. *-- Notes.......: Returns .T. if the first character of cChar is alphanumeric,
  300. *--               otherwise it is false.
  301. *-- Written for.: dBASE IV
  302. *-- Rev. History: None
  303. *-- Calls.......: None
  304. *-- Called by...: Any
  305. *-- Usage.......: IsAlNum("<cChar>")
  306. *-- Example.....: ? IsAlNum("Test")
  307. *-- Returns.....: Logical
  308. *-- Parameters..: cChar = character string to check for Alphanumeric ...
  309. *-------------------------------------------------------------------------------
  310.  
  311.     parameters cChar
  312.     
  313. RETURN isalpha( cChar ) .or. left( cChar, 1 ) $ "0123456789"
  314. *-- EoF: IsAlNum()
  315.  
  316. FUNCTION IsAscii
  317. *-------------------------------------------------------------------------------
  318. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  319. *-- Date........: 03/01/92
  320. *-- Notes.......: Returns .t. if the first character of cChar is in the lower
  321. *--               half of the ASCII set ( value < 128 )
  322. *-- Written for.: dBASE IV
  323. *-- Rev. History: None
  324. *-- Calls.......: None
  325. *-- Called by...: Any
  326. *-- Usage.......: IsAscii("<cChar>")
  327. *-- Example.....: ? IsAscii("Teststring")
  328. *-- Returns.....: Logical
  329. *-- Parameters..: cChar = string to test
  330. *-------------------------------------------------------------------------------
  331.  
  332.     parameters cChar
  333.     
  334. RETURN asc( cChar ) < 128
  335. *-- EoF: IsAscii()
  336.  
  337. FUNCTION IsCntrl
  338. *-------------------------------------------------------------------------------
  339. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  340. *-- Date........: 03/01/92
  341. *-- Notes.......: Returns .t. if the first character of cChar is a delete,
  342. *--               or a control character.
  343. *-- Written for.: dBASE IV
  344. *-- Rev. History: None
  345. *-- Calls.......: None
  346. *-- Called by...: Any
  347. *-- Usage.......: IsCntrl("<cChar>")
  348. *-- Example.....: ? IsCntrl("Test")
  349. *-- Returns.....: Logical
  350. *-- Parameters..: cChar = string to test
  351. *-------------------------------------------------------------------------------
  352.  
  353.     parameters cChar
  354.     private nCharval
  355.     nCharval = asc(cChar)
  356.     
  357. RETURN nCharval = 127 .or. nCharval < 32
  358. *-- EoF: IsCntrl()
  359.  
  360. FUNCTION IsDigit
  361. *-------------------------------------------------------------------------------
  362. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  363. *-- Date........: 03/01/92
  364. *-- Notes.......: If the first character of cChar is a digit, returns .T.
  365. *-- Written for.: dBASE IV
  366. *-- Rev. History: None
  367. *-- Calls.......: None
  368. *-- Called by...: Any
  369. *-- Usage.......: IsDigit("<cChar>")
  370. *-- Example.....: ? IsDigit("123Test")
  371. *-- Returns.....: Logical
  372. *-- Parameters..: cChar = string to test
  373. *-------------------------------------------------------------------------------
  374.  
  375.     parameters cChar
  376.  
  377. RETURN left( cChar, 1 ) $ "0123456789"
  378. *-- EoF: IsDigit()
  379.  
  380. FUNCTION IsPrint
  381. *-------------------------------------------------------------------------------
  382. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  383. *-- Date........: 03/01/92
  384. *-- Notes.......: Returns .t. if first character of cChar is a printing 
  385. *--               character (space through chr(126) ).
  386. *-- Written for.: dBASE IV
  387. *-- Rev. History: None
  388. *-- Calls.......: None
  389. *-- Called by...: Any
  390. *-- Usage.......: IsPrint("<cChar>")
  391. *-- Example.....: ? IsPrint("Test")
  392. *-- Returns.....: Logical
  393. *-- Parameters..: cChar = string to test
  394. *-------------------------------------------------------------------------------
  395.  
  396.     parameters cChar
  397.     private nCharval
  398.     nCharval = asc(cChar)
  399.     
  400. RETURN nCharval > 31 .and. nCharval < 127
  401. *-- EoF: IsPrint()
  402.  
  403. FUNCTION IsXDigit
  404. *-------------------------------------------------------------------------------
  405. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  406. *-- Date........: 03/01/92
  407. *-- Notes.......: Returns .t. if first character of cChar is a possible
  408. *--               hexidecimal digit.
  409. *-- Written for.: dBASE IV
  410. *-- Rev. History: None
  411. *-- Calls.......: None
  412. *-- Called by...: Any
  413. *-- Usage.......: IsXDigit("<cChar>")
  414. *-- Example.....: ? IsXDigit("F000")
  415. *-- Returns.....: Logical
  416. *-- Parameters..: cChar = string to test
  417. *-------------------------------------------------------------------------------
  418.  
  419.     parameters cChar
  420.     
  421. RETURN left( cChar, 1 ) $ "0123456789ABCDEFabcdef"
  422. *-- EoF: IsXDigit()
  423.  
  424. FUNCTION IsSpace
  425. *-------------------------------------------------------------------------------
  426. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  427. *-- Date........: 03/01/92
  428. *-- Notes.......: Returns .T. if first character of cChar is in set of space,
  429. *--               tab, carriage return, line feed, vertical tab or formfeed,
  430. *--               otherwise .F.  Differs from C function of the same
  431. *--               name in treating chr(141), used as carriage return
  432. *--               in dBASE memo fields, as a space.
  433. *-- Written for.: dBASE IV
  434. *-- Rev. History: None
  435. *-- Calls.......: None
  436. *-- Called by...: Any
  437. *-- Usage.......: IsSpace("<cChar>")
  438. *-- Example.....: ? IsSpace(" Test")
  439. *-- Returns.....: Logical
  440. *-- Parameters..: cChar = string to test
  441. *-------------------------------------------------------------------------------
  442.  
  443.     parameters cChar
  444.     private cSpacestr
  445.     cSpacestr = " "+chr(9)+chr(10)+chr(11)+chr(12)+chr(13)+chr(141)
  446.  
  447. RETURN left( cChar, 1 ) $ cSpacestr
  448. *-- EoF: IsSpace()
  449.  
  450. FUNCTION Name2Label
  451. *-------------------------------------------------------------------------------
  452. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  453. *-- Date........: 03/01/92
  454. *-- Notes.......: Returns a name held in five separate fields or memvars as it
  455. *--               should appear on a label of a given length in characters.
  456. *--               The order of abbreviating is somewhat arbitrary--you may
  457. *--               prefer to remove the suffix before the prefix, or to remove 
  458. *--               both before abbreviating the first name.  This can be 
  459. *--               accomplished by rearranging the CASE statements, which operate 
  460. *--               in the order of their appearance.
  461. *-- Written for.: dBASE IV
  462. *-- Rev. History: None
  463. *-- Calls.......: None
  464. *-- Called by...: Any
  465. *-- Usage.......: Name2Label(<nLength>,"<cPrefix>","<cFirstName>",;
  466. *--                          "<cMidName>","<cLastName>","<cSuffix>")
  467. *-- Example.....: ? Name2Label(20,"The Rev.","Elmore","Norbert","Smedley","III")
  468. *-- Returns.....: Character String, in this case "E. N. Smedley, III"
  469. *-- Parameters..: nLength     = length of label
  470. *--               cPrefix     = Prefix to name, such as Mr., Ms., Dr...
  471. *--               cFirstName  = self explanatory
  472. *--               cMiddleName = self explanatory
  473. *--               cLastName   = self explanatory
  474. *--               cSuffix     = "Jr.", "M.D.", "PhD", etc.
  475. *-------------------------------------------------------------------------------
  476.  
  477.     parameters nLength, cPrefix, cFirstname, cMidname, cLastname, cSuffix
  478.     private cTrypref, cTryfirst, cTrymid, cTrylast, cTrysuff, cTryname
  479.     cTrypref  = ltrim( trim( cPrefix ) )
  480.     cTryfirst = ltrim( trim( cFirstname ) )
  481.     cTrymid   = ltrim( trim( cMidname ) )
  482.     cTrylast  = ltrim( trim( cLastname ) )
  483.     cTrysuff  = ltrim( trim( cSuffix ) )
  484.     do while .t.
  485.       cTryname = cTrylast
  486.       if "" # cTrymid
  487.         cTryname = cTrymid + " " + cTryname
  488.       endif
  489.       if "" # cTryfirst
  490.         cTryname = cTryfirst + " " + cTryname
  491.       endif
  492.       if "" # cTrypref
  493.         cTryname = cTrypref + " " + cTryname
  494.       endif
  495.       if "" # cTrysuff
  496.         cTryname = cTryname + ", " + cTrysuff
  497.       endif
  498.       if len(cTryname) <= nLength
  499.          exit
  500.       endif
  501.       do case
  502.         case "" # cTrymid .AND. right( cTrymid, 1 ) # "."
  503.           cTrymid = left( cTrymid, 1 ) + "."    && convert middle name to initial
  504.         case "" # cTryfirst .AND. right( cTryfirst, 1 ) # "."
  505.           cTryfirst = left( cTryfirst, 1 ) + "." && convert first name to initial
  506.         case "" # cTrypref
  507.           cTrypref = ""                          && drop prefix
  508.         case "" # cTrysuff
  509.           cTrysuff = ""                          && drop suffix
  510.         case "" # cTrymid
  511.           cTrymid = ""                           && drop middle initial
  512.         case "" # cTryfirst
  513.           cTryfirst = ""                         && drop first initial
  514.         otherwise
  515.           cTrylast = left( cTrylast, nLength )   && truncate last name
  516.       endcase
  517.     enddo
  518.     
  519. RETURN cTryName
  520. *-- EoF: Name2Label()
  521.  
  522. FUNCTION StrPBrk
  523. *-------------------------------------------------------------------------------
  524. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  525. *-- Date........: 03/01/92
  526. *-- Notes.......: Search string for first occurrence of any of the
  527. *--               characters in charset.  Returns its position as
  528. *--               with at().  Contrary to ANSI.C definition, returns
  529. *--               0 if none of characters is found.
  530. *-- Written for.: dBASE IV
  531. *-- Rev. History: None
  532. *-- Calls.......: None
  533. *-- Called by...: Any
  534. *-- Usage.......: StrPBrk("<cCharSet>","<cBigStr>")
  535. *-- Example.....: ? StrPBrk("Tt","This is a Test string, with Test data")
  536. *-- Returns.....: Numeric value
  537. *-- Parameters..: cCharSet = characters to look for in cBigStr
  538. *--               cBigStr  = string to look in
  539. *-------------------------------------------------------------------------------
  540.  
  541.     parameters cCharset, cBigstring
  542.     private nPos, nLooklen
  543.     nPos = 0
  544.     nLooklen = len( cBigstring )
  545.     do while nPos < nLooklen
  546.       nPos = nPos + 1
  547.         if at( substr( cBigstring, nPos, 1 ), cCharset ) > 0
  548.          exit
  549.        endif
  550.     enddo
  551.     
  552. RETURN iif(nPos=nLookLen,0,nPos)
  553. *-- EoF: StrPBrk()
  554.  
  555. FUNCTION Rat
  556. *-------------------------------------------------------------------------------
  557. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  558. *-- Date........: 03/01/92
  559. *-- Notes.......: Reverse "at", returns position a character string is last
  560. *--               AT in a larger string.
  561. *-- Written for.: dBASE IV
  562. *-- Rev. History: None
  563. *-- Calls.......: None
  564. *-- Called by...: Any
  565. *-- Usage.......: Rat("<cFindStr>","<cBigStr>")
  566. *-- Example.....: ? Rat("Test","This is a Test string, with Test data")
  567. *-- Returns.....: Numeric value
  568. *-- Parameters..: cFindStr = string to find in cBigStr
  569. *--               cBigStr  = string to look in
  570. *-------------------------------------------------------------------------------
  571.  
  572.     parameters cFindstr, cBigstr
  573.     private nPos,nLen
  574.     nLen = len( cFindstr )
  575.     nPos = len( cBigstr ) - nLen + 1
  576.     do while nPos > 0
  577.         if substr( cBigstr, nPos, nLen ) = cFindstr
  578.             exit
  579.         else
  580.             nPos = nPos - 1
  581.         endif
  582.     enddo
  583.     
  584. RETURN max( nPos, 0 )
  585. *-- EoF: RAt()
  586.  
  587. FUNCTION StrRev
  588. *-------------------------------------------------------------------------------
  589. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  590. *-- Date........: 03/01/92
  591. *-- Notes.......: Reverses a string of characters, returns that reversed string.
  592. *-- Written for.: dBASE IV
  593. *-- Rev. History: None
  594. *-- Calls.......: None
  595. *-- Called by...: Any
  596. *-- Usage.......: StrRev("<cAnyStr>")
  597. *-- Example.....: ? StrRev("This is a Test")
  598. *-- Returns.....: Character string
  599. *-- Parameters..: cAnyStr = String of characters to reverse ...
  600. *-------------------------------------------------------------------------------
  601.  
  602.     parameters cAnystr
  603.     private cRevstring, nX,nY
  604.     nX = len( cAnystr )
  605.     nY = 1
  606.     cRevstring = space( nX )
  607.     do while nX > 0
  608.           cRevstring = stuff(cRevstring,nY,1,substr(cAnyStr,nX,1))
  609.       nY = nY + 1
  610.       nX = nX - 1
  611.     enddo
  612.     
  613. RETURN cRevstring
  614. *-- EoF: StrRev()
  615.  
  616. FUNCTION Strip2Val
  617. *-------------------------------------------------------------------------------
  618. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  619. *-- Date........: 03/01/92
  620. *-- Notes.......: Strip characters from the left of a string until reaching
  621. *--               one that might start a number.
  622. *-- Written for.: dBASE IV
  623. *-- Rev. History: None
  624. *-- Calls.......: None
  625. *-- Called by...: Any
  626. *-- Usage.......: Strip2Val("<cStr>")
  627. *-- Example.....: ? Strip2Val("Test345")
  628. *-- Returns.....: character string
  629. *-- Parameters..: cStr = string to search
  630. *-------------------------------------------------------------------------------
  631.  
  632.     parameters cStr
  633.    private cNew
  634.    cNew = cStr
  635.    do while "" # cNew
  636.       if left( cNew, 1 ) $ "-.0123456789"
  637.          exit
  638.        endif
  639.       cNew = substr( cNew, 2 )
  640.     enddo
  641.     
  642. RETURN cNew
  643. *-- EoF: Strip2Val()
  644.  
  645. FUNCTION StripVal
  646. *-------------------------------------------------------------------------------
  647. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  648. *-- Date........: 03/01/92
  649. *-- Notes.......: Strip characters from the left of the string until
  650. *--               reaching one that is not part of a number.  A hyphen
  651. *--               following numerics, or a second period,
  652. *--               is treated as not part of a number.
  653. *-- Written for.: dBASE IV
  654. *-- Rev. History: None
  655. *-- Calls.......: None
  656. *-- Called by...: Any
  657. *-- Usage.......: StripVal("<cStr>")
  658. *-- Example.....: ? StripVal("123.2Test")
  659. *-- Returns.....: Character
  660. *-- Parameters..: cStr = string to test
  661. *-------------------------------------------------------------------------------
  662.  
  663.     parameters cStr
  664.    private cNew, cChar, lGotminus, lGotdot
  665.    cNew = cStr
  666.    store .f. to lGotminus, lGotdot
  667.    do while "" # cNew
  668.       cChar = left( cNew, 1 )
  669.        do case
  670.           case .not. cChar $ "-.0123456789"
  671.             exit
  672.          case cChar = "-"
  673.              if lGotminus
  674.                exit
  675.             endif
  676.            case cChar = "."
  677.              if lGotdot
  678.                exit
  679.              else
  680.                 lGotdot = .T.
  681.              endif
  682.        endcase
  683.       cNew = substr( cNew, 2 )
  684.        lGotminus = .T.
  685.     enddo
  686.     
  687. RETURN cNew
  688. *-- EoF: StripVal()
  689.  
  690. FUNCTION ParseWord
  691. *-------------------------------------------------------------------------------
  692. *-- Programmer..: Jay Parsons (CIS: 70160,340).
  693. *-- Date........: 04/26/1992
  694. *-- Notes.......: returns the first word of a string
  695. *-- Written for.: dBASE IV, 1.1, 1.5
  696. *-- Rev. History: None
  697. *-- Calls       : None
  698. *-- Called by...: Any
  699. *-- Usage.......: ? ParseWord(<cString>)
  700. *-- Example.....: Command = ParseWord( cProgramline )
  701. *-- Parameters..: cString - character string to be stripped.
  702. *-- Returns     : that portion, trimmed on both ends, of the passed string
  703. *--               that includes the characters up to the first interior space.
  704. *-------------------------------------------------------------------------------
  705.    parameters string
  706.    private cW
  707.    cW = trim( ltrim( string ) )
  708.  
  709. RETURN iif( " " $ cW, rtrim( left( cW, at( " ", cW ) - 1 ) ), cW )
  710. *-- EoF: ParseWord()
  711.  
  712. FUNCTION StripWord
  713. *-------------------------------------------------------------------------------
  714. *-- Programmer..: Jay Parsons (CIS: 70160,340).
  715. *-- Date........: 04/26/1992
  716. *-- Notes.......: discards first word of a string
  717. *-- Written for.: dBASE IV, 1.1, 1.5
  718. *-- Rev. History: None
  719. *-- Calls       : None
  720. *-- Called by...: Any
  721. *-- Usage.......: ? StripWord(<cString>)
  722. *-- Example.....: Lastname = StripWord( "Carrie Nation" )
  723. *-- Parameters..: cString - character string to be stripped.
  724. *-- Returns     : string trimmed of trailing spaces, and trimmed on the
  725. *--               left to remove leading spaces and, if the passed string
  726. *--               contained interior spaces, also to remove everything before
  727. *--               the first nonspace character after the first interior space.
  728. *-------------------------------------------------------------------------------
  729.    parameters string
  730.    private cW
  731.    cW = trim( ltrim( string ) )
  732.  
  733. RETURN iif( " " $ cW, ltrim( substr( cW, at( " ", cW ) + 1 ) ), cW )
  734. *-- EoF: StripWord()
  735.  
  736. FUNCTION Plural
  737. *-------------------------------------------------------------------------------
  738. *-- Programmer..: Kelvin Smith (KELVIN)
  739. *-- Date........: 08/27/1992
  740. *-- Notes.......: Returns number in string form, and pluralized form of
  741. *--               noun, including converting "y" to "ies", unless the "y"
  742. *--               is preceded by a vowel.  Works with either upper or lower
  743. *--               case nouns (based on last character).
  744. *--                  As no doubt all are aware, English includes many
  745. *--               irregular plural forms; to trap for all is not worthwhile
  746. *--               (how often do you really need to print out die/dice?).
  747. *--               This should handle the vast majority of needs.
  748. *-- Written for.: dBASE IV, 1.5
  749. *-- Rev. History: 08/27/1992 1.0 - Original version
  750. *-- Calls.......: None
  751. *-- Called by...: Any
  752. *-- Usage.......: Plural(<nCnt>, <cNoun>)
  753. *-- Examples....: Plural(1, "flag")    returns "1 flag"
  754. *--               Plural(0, "store")   returns "0 stores"
  755. *--               Plural(5, "COMPANY") returns "5 COMPANIES"
  756. *-- Returns.....: String with number and noun, no trailing spaces
  757. *-- Parameters..: nCnt  = Count value for noun (how many of cNoun?)
  758. *--               cNoun = Noun to pluralize
  759. *-------------------------------------------------------------------------------
  760.  
  761.    parameters nCnt, cNoun
  762.    private cNounOut, cLast, c2Last, cLast2, lUpper
  763.  
  764.    if nCnt = 1
  765.       cNounOut = trim(cNoun)
  766.    else
  767.       cNounOut = trim(cNoun)          && No trailing spaces
  768.       cLast = right(cNounOut, 1)
  769.       lUpper = isupper(cLast)         && Upper case?
  770.       cLast = upper(cLast)
  771.       c2Last = upper(substr(cNounOut, len(cNounOut) - 1, 1))
  772.       cLast2 = c2Last + cLast
  773.  
  774.       * If the noun ends in "Y", normally we change "Y" to "IES".
  775.       * However, if the "Y" is preceded by a vowel, just add "S".
  776.       if cLast = "Y" .and. at(c2Last, "AEIOU") = 0
  777.          cNounOut = left(cNounOut, len(cNounOut) - 1) +;
  778.                     iif(lUpper, "IES", "ies")
  779.       else
  780.          if cLast = "S" .or. cLast = "X" ;
  781.                         .or. cLast2 = "CH" .or. cLast2 = "SH"
  782.             cNounOut = cNounOut + iif(lUpper, "ES", "es")
  783.          else
  784.             cNounOut = cNounOut + iif(lUpper, "S", "s")
  785.          endif
  786.       endif
  787.    endif
  788.  
  789. RETURN ltrim(str(nCnt)) + " " + cNounOut
  790. *-- EoF: Plural()
  791.  
  792. FUNCTION StrComp
  793. *-------------------------------------------------------------------------------
  794. *-- Programmer..: Sri Raju (Borland Technical Support)
  795. *-- Date........: 08/xx/1992
  796. *-- Notes.......: From Technotes, August, 1992, "Strings and Things"
  797. *--               This function compares the contents of two strings.
  798. *--               If cStr1 is less than cStr2, return -1
  799. *--               If cStr1 is equal to  cStr2, return 0
  800. *--               If cStr1 is greaterh than cStr2, return 1
  801. *-- Written for.: dBASE IV, 1.5
  802. *-- Rev. History: None
  803. *-- Calls.......: None
  804. *-- Called by...: Any
  805. *-- Usage.......: StrComp(<cStr1>,<cStr2>)
  806. *-- Example.....: ? StrComp("TEST","TEXT")
  807. *-- Returns.....: Numeric (see notes)
  808. *-- Parameters..: cStr1 = First string
  809. *--               cStr2 = Second string
  810. *-------------------------------------------------------------------------------
  811.     
  812.     parameters cStr1,cStr2
  813.     
  814.     cExact = set("EXACT")
  815.     set exact on
  816.     
  817.     do case
  818.         case cStr1 = cStr2
  819.             nReturn = 0
  820.         case cStr1 > cStr2
  821.             nReturn = 1
  822.         case cStr1 < cStr2
  823.             nReturn = -1
  824.     endcase
  825.     
  826.     set exact &cExact
  827.  
  828. RETURN nReturn
  829. *-- EoF: StrComp()
  830.  
  831. FUNCTION StrOccur
  832. *-------------------------------------------------------------------------------
  833. *-- Programmer..: Sri Raju (Borland Technical Support)
  834. *-- Date........: 08/xx/1992
  835. *-- Notes.......: TechNotes, August, 1992, "Strings and Things"
  836. *--               Calculates the number of occurences of a string in another
  837. *--               given character or memo field.
  838. *-- Written for.: dBASE IV, 1.5
  839. *-- Rev. History: None
  840. *-- Calls.......: NumOccur()           Function in STRINGS.PRG
  841. *-- Called by...: Any
  842. *-- Usage.......: StrOccur(<cInString>,<cFindString>)
  843. *-- Example.....: ? StrOccur("NOTES","every")  && find all occurences of "every"
  844. *--                                            && in Memo: NOTES.
  845. *-- Returns.....: Numeric
  846. *-- Parameters..: cInString   = "Large" string -- to be looked "in". If a Memo,
  847. *--                             name of memo field must be in quotes or passed
  848. *--                             as a memvar, and record pointer must be on
  849. *--                             correct record.
  850. *--               cFindString = "Small" string -- to be found in larger string.
  851. *-------------------------------------------------------------------------------
  852.  
  853.     parameters cInString, cFindString
  854.     
  855.     nBytes = 0
  856.     lMemo = .f.
  857.     nReturn = 0
  858.     
  859.     if pCount() # 2   && not enough parameters or too many parameters passed ...
  860.         ?"ERROR. Usage: StrOccur(<string>|<memo fld name>,<string>)"
  861.         RETURN (0)
  862.     endif
  863.     if type("CINSTRING") = "M"
  864.         lMemo = .t.
  865.     else
  866.         RETURN (NumOccur(cInstring,cFindString))
  867.     endif
  868.     
  869.     *-- process a memo ...
  870.     if lMemo
  871.         nTotLen = len(&cInString)
  872.         n = 1
  873.         nOffSet = 0
  874.         cTempStr = " "
  875.         do while nOffSet <= nTotLen
  876.             cTempStr = "arr"+ltrim(str(n))  && ?
  877.             if (nOffSet + 254) > nTotLen
  878.                 cTempStr = substr(&cInString,nOffSet+1,nOffSet+254)
  879.             else
  880.                 cTempStr = substr(&cInString,nOffSet+1,nTotLen)
  881.             endif
  882.             nReturn = nReturn + NumOccur(cTempStr,cFindStr)
  883.             n = n + 1
  884.             nOffSet = nOffSet + 254
  885.         enddo
  886.     endif
  887.  
  888. RETURN (nReturn)
  889. *-- EoF: StrOccur()
  890.  
  891. FUNCTION NumOccur
  892. *-------------------------------------------------------------------------------
  893. *-- Programmer..: Sri Raju (Borland Technical Support)
  894. *-- Date........: 08/xx/1992
  895. *-- Notes.......: TechNotes, August, 1992, "Strings and Things"
  896. *--               Calculates the number of occurences of a string in another
  897. *--               string.
  898. *-- Written for.: dBASE IV, 1.5
  899. *-- Rev. History: None
  900. *-- Calls.......: None
  901. *-- Called by...: StrOccur()           Function in STRINGS.PRG
  902. *-- Usage.......: NumOccur(<cInString>,<cFindString>)
  903. *-- Example.....: ? NumOccur("This is a string","is")
  904. *-- Returns.....: Numeric (integer -- # of times string occurs)
  905. *-- Parameters..: cInString   = "Large" string -- to be looked 'in'
  906. *--               cFindString = "Small" string -- to be looked for
  907. *-------------------------------------------------------------------------------
  908.  
  909.     parameters cInString, cFindString
  910.     
  911.     cHoldStr = " "
  912.     nReturn = 0
  913.     cInit = cInString
  914.     
  915.     do while len(cInit) => 1
  916.         cHoldStr = cInit
  917.         if at(cFindString,cHoldStr) > 0
  918.             nReturn = nReturn + 1
  919.             cInit = substr(cHoldStr,at(cFindString,cHoldStr)+len(cFindString))
  920.         else
  921.             cInit = ""
  922.         endif
  923.     enddo
  924.  
  925. RETURN (nReturn)
  926. *-- EoF: NumOccur()
  927.  
  928. FUNCTION ReplMemo
  929. *-------------------------------------------------------------------------------
  930. *-- Programmer..: Sri Raju (Borland Technical Support)
  931. *-- Date........: 08/xx/1992
  932. *-- Notes.......: TechNotes, August, 1992, "Strings and Things"
  933. *--               Globally searches and replaces a string with another string
  934. *--               in a character field/memvar or memo field.
  935. *-- Written for.: dBASE IV, 1.5
  936. *-- Rev. History: None
  937. *-- Calls.......: MemStuff()           Function in STRINGS.PRG
  938. *-- Called by...: Any
  939. *-- Usage.......: ReplMemo("cSource",<cCurrStr>,<cNewStr>)
  940. *-- Example.....: ?ReplMemo("NOTES","Test","testing")
  941. *-- Returns.....: .T. if a memo field, or character string with changes
  942. *-- Parameters..: cSource  = Source to make changes IN
  943. *--               cCurrStr = Current string (item(s)) to be changed
  944. *--               cNewStr  = Change 'Current' to this ....
  945. *-------------------------------------------------------------------------------
  946.  
  947.     parameters cSource, cCurrStr, cNewStr
  948.     cConsole = set("CONSOLE")
  949.     
  950.     nBytes = 0
  951.     nPointer = 0
  952.     nMaster = 0
  953.     
  954.     *-- error
  955.     if pcount() # 3   && valid number of parms
  956.         ?"Error."
  957.         ?"Usage: ReplMemo(<Memo/string>,<Current String>,<New String>)"
  958.         RETURN .f.
  959.     endif
  960.     
  961.     *-- start
  962.     if type(cSource) = "M"                         && if a memo ...
  963.         if len(&cSource) > 254                      && if > 254 char
  964.             cNewFile = (cSource)+".TXT"              && create a temp file
  965.             erase cNewFile
  966.             nPointer = fcreate(cNewFile,"A")
  967.         endif
  968.     else
  969.         *-- if not a memo, just perform the replace ...
  970.         RETURN (MemStuff(cSource,cCurrStr,cNewStr))
  971.     endif
  972.     
  973.     *-- memo handling ...
  974.     nTotLen = len(&cSource)
  975.     nCounter = 1
  976.     nOffSet = 0
  977.     do while nOffSet <= nTotLen
  978.         cTempStr = "arr"+ltrim(str(nCounter))
  979.         if (nOffSet+200) < nTotLen
  980.             cTempStr = substr(&cSource,nOffSet+1,200)
  981.         else
  982.             cTempStr = substr(&cSource,nOffSet+1,nTotLen)
  983.         endif
  984.         cTemp2 = space(200)
  985.         cTemp2 = MemStuff(cTempStr, cCurrStr, cNewStr)
  986.         nBytes = fwrite(nPointer,cTemp2)
  987.         
  988.         nCounter = nCounter + 1
  989.         nOffSet = nOffSet + 200
  990.     enddo
  991.     
  992.     nNull = fclose(nPointer)
  993.     append memo &cSource) from (newfile) overwrite
  994.  
  995. RETURN .T.
  996. *-- EoF: ReplMemo()
  997.  
  998. FUNCTION MemStuff
  999. *-------------------------------------------------------------------------------
  1000. *-- Programmer..: Sri Raju (Borland Technical Support)
  1001. *-- Date........: 08/xx/1992
  1002. *-- Notes.......: TechNotes, August, 1992, "Strings and Things"
  1003. *--               Replaces a specific string in a character string, by another,
  1004. *--               and returns the resultant string.
  1005. *-- Written for.: dBASE IV, 1.5
  1006. *-- Rev. History: None
  1007. *-- Calls.......: Stub()               Function in STRINGS.PRG
  1008. *-- Called by...: ReplMemo()           Funciton in STRINGS.PRG
  1009. *-- Usage.......: MemStuff(<cSource>,<cCurrStr>,<cNewStr>)
  1010. *-- Example.....: ? MemStuff(cTestStr,"Test","Testing")
  1011. *-- Returns.....: Character
  1012. *-- Parameters..: cSource  = Source to make changes IN
  1013. *--               cCurrStr = Current string (item(s)) to be changed
  1014. *--               cNewStr  = Change 'Current' to this ....
  1015. *-------------------------------------------------------------------------------
  1016.  
  1017.     parameters cSource, cCurrStr, cNewStr
  1018.     private cSource, cCurrStr, cNewStr
  1019.     cRetStr  = ""
  1020.     cHoldStr = ""
  1021.     cInitStr = cSource
  1022.     
  1023.     do while len(cInitStr) => 1
  1024.         cHoldStr = cInitStr
  1025.         if at(cCurrStr,cNewStr) > 0
  1026.             cTemp = substr(cInitStr,1,at(cCurrStr,cHoldStr))
  1027.             nPos  = at(cCurrStr,cHoldStr)
  1028.             cReturn = cReturn+Stub(cTemp,nPos,cNewStr)
  1029.             cInitStr = substr(cHoldStr,at(cReplace,cHoldStr)+len(cNewStr))
  1030.         else
  1031.             cReturn = trim(cInitStr)+trim(cHoldStr)
  1032.             cInitStr = ""
  1033.         endif
  1034.     enddo
  1035.  
  1036. RETURN (cReturn)
  1037. *-- EoF: MemStuff()
  1038.  
  1039. FUNCTION Stub
  1040. *-------------------------------------------------------------------------------
  1041. *-- Programmer..: Sri Raju (Borland Technical Support)
  1042. *-- Date........: 08/xx/1992
  1043. *-- Notes.......: This returns a specific number of characters from the given
  1044. *--               string specified by the parameter innum, added to the
  1045. *--               third parameter.
  1046. *-- Written for.: dBASE IV, 1.5
  1047. *-- Rev. History: None
  1048. *-- Calls.......: None
  1049. *-- Called by...: MemStuff()           Function in STRINGS.PRG
  1050. *-- Usage.......: Stub(<cString>,nIn,<cIn>)
  1051. *-- Example.....: ? Stub(cTest,5,"Test")
  1052. *-- Returns.....: Character
  1053. *-- Parameters..: cString = Character string to look in
  1054. *--               nIn     = # of characters to return
  1055. *--               cIn     = characters to add to the end of ...
  1056. *-------------------------------------------------------------------------------
  1057.  
  1058.     parameters cString, nIn, cIn
  1059.  
  1060. RETURN trim(substr(cString,1,nIn-1)+cIn)
  1061. *-- EoF: Stub()
  1062.  
  1063. FUNCTION FirstMem
  1064. *-------------------------------------------------------------------------------
  1065. *-- Programmer..: Sri Raju (Borland Technical Support)
  1066. *-- Date........: 08/xx/1992
  1067. *-- Notes.......: TechNotes, August, 1992, "Strings and Things"
  1068. *--               Capitalizes the first character of all the words in the string
  1069. *--               that is passed as a parameter, and returns the resultant
  1070. *--               string. If a name of a memo field is pass as the parameter,
  1071. *--               it re-writes the memo field, and returns a .T.
  1072. *-- Written for.: dBASE IV, 1.5
  1073. *-- Rev. History: None
  1074. *-- Calls.......: FirstCap()           Function in STRINGS.PRG
  1075. *-- Called by...: None
  1076. *-- Usage.......: FirstMem(cInStr)
  1077. *-- Example.....: ? FirstMem("this is a string")
  1078. *-- Returns.....: Either character string with first letter of each word
  1079. *--               capitalized, or .T. (if a Memo).
  1080. *-- Parameters..: cInStr = character string or Memo Field name
  1081. *-------------------------------------------------------------------------------
  1082.     
  1083.     parameters cInStr
  1084.  
  1085.     nBytes = 0
  1086.     lMemo = .F.
  1087.     lReturn = .T.
  1088.     nFPtr = 0
  1089.     nMasterCnt = 0
  1090.  
  1091.     if pcount() # 1
  1092.         ? "Error."
  1093.         ? "Usage:- FIRSTMEM (<string>) "
  1094.         lMemo = .F.
  1095.     else
  1096.         if type(instr) = "M"
  1097.             lMemo = .T.
  1098.             cNewFile = (cInStr) + ".txt"
  1099.             erase (cnewfile)
  1100.             nFPtr = fcreate(cNewFile, "A")
  1101.         else
  1102.             lReturn = .F.
  1103.         endif
  1104.     endif
  1105.         
  1106.     if lMemo 
  1107.         nTotLen = len(&CInStr)
  1108.         nCntr = 1
  1109.         nOffSet = 0
  1110.             do while nOffSet <= nTotLen
  1111.                 if (nOffSet + 250) < nTotLen
  1112.                     cTemp = substr(&cInStr, nOffSet + 1, 250)
  1113.                 else
  1114.                     cTemp = substr(&CInStr, nOffSet + 1, nTotLen)
  1115.                 endif
  1116.                 cTempStr = space(250)
  1117.                 cTempStr = FirstCap(cTemp)
  1118.                 nBytes = fwrite(nFPtr, cTempStr)
  1119.                 
  1120.                 nCntr = nCntr + 1
  1121.                 nOffSet = nOffSet + 250
  1122.             enddo
  1123.             x = fclose(nFPtr)
  1124.             append memo &cInStr from (CNewFile) overwrite
  1125.     endif
  1126.  
  1127.     if lMemo .or. lReturn
  1128.         RETURN (.F.)
  1129.     else
  1130.         RETURN (FirstCap(cInStr))
  1131.     endif
  1132. *-- EoF: FirstMem()
  1133.  
  1134. FUNCTION FirstCap
  1135. *-------------------------------------------------------------------------------
  1136. *-- Programmer..: Sri Raju (Borland Technical Support)
  1137. *-- Date........: 08/xx/1992
  1138. *-- Notes.......: TechNotes, August, 1992, "Strings and Things"
  1139. *--               Capitalizes the first character of a string.
  1140. *-- Written for.: dBASE IV, 1.5
  1141. *-- Rev. History: None
  1142. *-- Calls.......: None
  1143. *-- Called by...: FirstMem()           Function in STRINGS.PRG
  1144. *-- Usage.......: FirstCap(<cInString>) 
  1145. *-- Example.....: ?FirstCap("stringofcharacters")
  1146. *-- Returns.....: String with first character captilized.
  1147. *-- Parameters..: cInString = String to cap the first letter of
  1148. *-------------------------------------------------------------------------------
  1149.  
  1150.     parameters cInString
  1151.     cRetString = ""
  1152.     cIStr = cInString
  1153.  
  1154.     do while len(cIStr) > 1
  1155.         nPos = at(" ", cIStr) 
  1156.         if nPos <> 0
  1157.             cRetString = cRetString + upper(left(cIStr, 1)) + ;
  1158.                 substr(cIStr, 2, nPos-1)
  1159.         else
  1160.             cRetString = cRetString + upper(left(cIStr, 1)) + substr(cIStr, 2)
  1161.             exit
  1162.         endif
  1163.         do while substr(cIStr, nPos, 1) = " "
  1164.             nPos = nPos + 1
  1165.         enddo
  1166.         cIStr = substr(cIStr, nPos)
  1167.     enddo
  1168.  
  1169. RETURN (cRetString)
  1170. *-- EoF: FirstCap()
  1171.  
  1172. FUNCTION StripND
  1173. *-------------------------------------------------------------------------------
  1174. *-- Programmer..: Kenneth J. Mayer (CIS: 71333,1030)
  1175. *-- Date........: 01/04/1993
  1176. *-- Notes.......: Strips characters out of a numeric character string (like
  1177. *--               perhaps, a date ... 01/04/93 would become 010493)
  1178. *-- Written for.: dBASE IV, 1.5
  1179. *-- Rev. History: None
  1180. *-- Calls.......: IsDigit()            Function in STRINGS.PRG
  1181. *-- Called by...: Any
  1182. *-- Usage.......: StripND(<cNumArg>)
  1183. *-- Example.....: keyboard stripnd(dtoc(date()))
  1184. *-- Returns.....: character string
  1185. *-- Parameters..: cNumArg = Character memvar containing a "numeric" string
  1186. *-------------------------------------------------------------------------------
  1187.  
  1188.     parameters cNumArg
  1189.     private cNumStr, nLen, cRetVal, nCount, cChar
  1190.     cNumStr = cNumArg
  1191.     nLen = len(cNumStr)
  1192.     cRetVal = ""
  1193.     nCount = 0
  1194.     do while nCount <= nLen
  1195.         nCount = nCount + 1
  1196.         cChar = substr(cNumStr,nCount,1)
  1197.         if isdigit(cChar)
  1198.             cRetVal = cRetVal+cChar
  1199.         endif
  1200.     enddo
  1201.  
  1202. RETURN cRetVal
  1203. *-- EoF: StripND()
  1204.  
  1205. FUNCTION Strip
  1206. *-------------------------------------------------------------------------------
  1207. *-- Programmer..: Kenneth Chan [ZAK] (CIS: 71542,2712)
  1208. *-- Date........: 01/05/1993
  1209. *-- Notes.......: Strips out specified character(s) from a string
  1210. *-- Written for.: dBASE IV, 1.5
  1211. *-- Rev. History: None
  1212. *-- Calls.......: None
  1213. *-- Called by...: Any
  1214. *-- Usage.......: Strip(<cVar>,<cArg>)
  1215. *-- Example.....: ?strip(dtoc(date(),"/")
  1216. *-- Returns.....: Character
  1217. *-- Parameters..: cVar = variable/field to remove character(s) from
  1218. *--               cArg = item to remove from cVar
  1219. *-------------------------------------------------------------------------------
  1220.  
  1221.   parameter cVar, cArg
  1222.   do while cArg $ cVar
  1223.     cVar = stuff( cVar, at( cArg, cVar ), 1, "" )
  1224.   enddo
  1225.  
  1226. RETURN cVar
  1227. *-- EoF: Strip()
  1228.  
  1229. PROCEDURE WordWrap
  1230. *-------------------------------------------------------------------------------
  1231. *-- Programmer..: David Frankenbach (CIS: 72147,2635)
  1232. *-- Date........: 01/14/1993 (Version 1.1)
  1233. *-- Notes.......: Wraps a long string, breaking it into strings that have
  1234. *--               a maximum length of nWidth. The first output is displayed
  1235. *--               @nRow, nCol. Words are not split ...
  1236. *-- Written for.: dBASE IV, 1.5
  1237. *-- Rev. History: 01/06/1993 -- Original Release (Version 1.0)
  1238. *--               01/14/1993 -- Version 1.1 -- Corrected side-effect of 
  1239. *--                       destroying string arg, added test for 
  1240. *--                       string[nWidth+1] = " "
  1241. *-- Calls.......: None
  1242. *-- Called by...: Any
  1243. *-- Usage.......: do WordWrap with <nRow>, <nCol>, <cString>, <nWidth>
  1244. *-- Example.....: do WordWrap with 2,2,cText,38
  1245. *-- Returns.....: None
  1246. *-- Parameters..: nRow     = Row to display first line at
  1247. *--               nCol     = Left side of area to display text at
  1248. *--               cString  = text to wrap
  1249. *--               nWidth   = Width of area to wrap text in
  1250. *-------------------------------------------------------------------------------
  1251.  
  1252.     parameters nRow, nCol, cString, nWidth
  1253.     private cTemp, nI, cStr
  1254.     
  1255.     cStr = cString                  && work with a COPY of input, to avoid
  1256.                                     && destroying original
  1257.     
  1258.     do while len(cStr) > 0          && while there's something to work on
  1259.         if (nWidth < len(cStr))
  1260.             nI = nWidth               && look for last " " in first nWidth
  1261.             
  1262.             if substr(cStr,nI+1,1) # " "
  1263.                 do while ( (nI > 0) .and. (substr(cStr,nI,1) # " ") )
  1264.                     nI = nI - 1
  1265.                 enddo
  1266.             endif
  1267.             
  1268.             if nI = 0                 && no spaces
  1269.                 nI = nWidth            && get first nWidth characters
  1270.             endif
  1271.         else
  1272.             nI = len(cStr)         && use the rest of the string
  1273.         endif
  1274.         
  1275.         cTemp = left(cStr,nI)     && get the part we're going to display
  1276.         
  1277.         if nI < len(cStr)         && remove that part
  1278.            cStr = ltrim(substr(cStr,nI + 1))
  1279.         else
  1280.             cStr = ""
  1281.         endif
  1282.         
  1283.         *-- display it
  1284.         @nRow,nCol say cTemp
  1285.         *-- move to next row
  1286.         nRow = nRow + 1
  1287.         
  1288.     enddo
  1289.     
  1290. RETURN
  1291. *-- EoP: WordWrap
  1292.  
  1293. *-------------------------------------------------------------------------------
  1294. *-- EoP: STRINGS.PRG
  1295. *-------------------------------------------------------------------------------
  1296.